Delphi Programmer's Power Pack/Delphi Volume 1.iso/e_to_l/isamexpt/isambrow.pas

Pascal/Delphi Source File | 1996-09-15 | 20.7 KB | 601 lines

unit Isambrow;
{copyright 1995 by Norbert Stellberg GmbH,
 parts that are signed with a "*" copyright by TURBO POWER
 or Michael Williams CompuServe: 71552,757 }
interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls,
  LowBrows, Fvcbrows, Filer, IsamTabl;

type
  Feld_GetProc = Function(Feld: Integer;
                          Table: TIsamTable;
                          var DATA): String;
  {FELD_GETPROC will be created by the expert in
   the browser-unit.
   It will get the data-fields from your record.
   Example:
     Function TestGetFeldProc(Feld: Integer; Table: TIsamTable; var DATA): String; far;
     var S: String;
     begin
       S:= '';
       With TESTRECORD(Data) do begin
       Case Feld of
         1: s:= String_oem2ansi(Table.AnsiConvert,NAME1)+'^';
         2: s:= String_oem2ansi(Table.AnsiConvert,NAME2)+'^';
         3: s:= String_oem2ansi(Table.AnsiConvert,STREET)+'^';
         4: s:= String_oem2ansi(Table.AnsiConvert,ZIP)+'^';
         5: s:= String_oem2ansi(Table.AnsiConvert,CITY)+'^';
         6: s:= DateStr(DATE)+'^';
         7: s:= FormDezStr(AGE,10);
      end;
    end;
    Result:= S;
  end;   }

  TIsamBrowser = class(TFvcBrowser)
    {a descendant of the TFVCBROWSER-Object, whose copyright is
     by TURBO POWER INC.
     Vars and Procs, signed by a "*" are copied from the TFVCBROWSER.
     the copyright will still be held by TURBO POWER}
  private
    { Private declarations }
    FHeader         : THeader;      {a normal header for your browser}
    FSpalten        : TStringList;  {a list of TUEBERSCHRIFTOBJECTS .. see ISBRINST.INT}
    FTable          : TIsamTable;   {the isamtable, that will be browsed}
    FKeySection     : integer; { * Which header section are we searching on }
    FSeparatorChar  : char;    { * Default '^'  }
    FJustLeftChar   : char;    { * Default #255 }
    FJustRightChar  : char;    { * Default #255 }
    FJustCenterChar : char;    { * Default #255 }
    FAllowIncss     : boolean; { * }
    FIncSSColor     : TColor;  { * }
    FIncSSTxtColor  : TColor;  { * }
    Procedure SetTable(const Value: TIsamTable);
    Procedure SetSpalten(const Value: TStringList);
  protected
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    function  WriteStringOut(var S      : BRLRowEltString;
                                 LineNr : word;
                                 XOfs   : integer): word; override;
    procedure ShowErrorOccured(EClass: Integer); override;
  public
    BaseLKey    : IsamKeyStr; { * }
    BaseHKey    : IsamKeyStr; { * }
    IncSS       : IsamKeyStr;  { * Incremental search string }
    FTextMargin : TRect;      { * }
    Procedure ResizeHeader;  {must be called after you changed the
                              field widths by drag and drop in your
                              browser}
    Function ReadIni: Integer; {will read browser-settings from an ini-file,
                               {must be called after creating the form and
                                before showing the browser-form.}
    Procedure SetupBrowser(aParent: TForm); {will show the browser-setup-dialog,
                                see ISBRINST.INT}
    Function GetRow(GetProc: Feld_GetProc; var DATA):String;
                              {called by the browser to show the data fields}
    Function GetLowBrowser: PLowWinBrowser;
  published
    { Published declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property BrowserHeader  : THeader read FHeader write FHeader;
    property Spalten        : TStringList read FSpalten write SetSpalten;
    property Table          : TIsamTable read FTable write SetTable;
    property KeySection     : {*}integer read FKeySection write FKeySection;
    property SeparatorChar  : {*}char read FSeparatorChar write FSeparatorChar;
    property JustLeftChar   : {*}char read FJustLeftChar write FJustLeftChar;
    property JustRightChar  : {*}char read FJustRightChar write FJustRightChar;
    property JustCenterChar : {*}char read FJustCenterChar write FJustCenterChar;
    property AllowIncSS     : {*}boolean read FAllowIncSS write FAllowIncSS;
    property IncSSColor     : {*}TColor read FIncSSColor write FIncSSColor;
    property IncSSTxtColor  : {*}TColor read FIncSSTxtColor write FIncSSTxtColor;
    procedure ClearIncss;     {*}
  end;

Function GetAppName: String;  {procedure, to get the name of your application during runtime}

implementation

Uses UToolDll, IniFiles, IsBrInst;

Var AppName: String;

Function GetAppName: String;
var G: String;
    xPos: Integer;
begin
  G:= Application.ExeName;
  xPos:= Pos('\',G);
  While xPos > 0 do begin
    Delete(G,1,xPos);
    xPos:= Pos('\',G);
  end;
  xPos:= Pos('.',G);
  if xPos > 0 then G:= Copy(G,1,xPos-1);
  AppName:= G;
  GetAppName:= G;
end;

constructor TIsamBrowser.Create(AOwner : TComponent);
begin
  Inherited Create(AOwner);
  IncSS := '';
  SeparatorChar := '^';
  FJustLeftChar := #255;
  FJustCenterChar := #255;
  FJustRightChar := #255;
  BaseLKey := LowKey;
  BaseHKey := HighKey;
  FIncSSColor := clRed;
  FIncssTxtColor := clWhite;
  FSpalten:= TStringList.Create;
end;

Function TIsamBrowser.GetLowBrowser: PLowWinBrowser;
begin
  Result:= BrowserPtr;
end;

Destructor TIsamBrowser.Destroy;
begin
  FSpalten.Free;
  Inherited Destroy;
end;

Function TIsamBrowser.ReadIni: Integer;
var BrwListe,SListe: TStringList;
    BrwIni: TIniFile;
    FNr,K,i,Code,idx,Arr1,Arr2,Feld: Integer;
    SStr,AktDir,LStr,LenStr,FeldName: String;
    x,Len: Longint;
begin
  AktDir:= ExtractFilePath(Application.ExeName);
  K:= 1;
  BrwIni:= TIniFile.Create(AktDir + GetAppName+'.INI');
  BrwListe:= TStringList.Create;
  SListe:= TStringList.Create;
  K:= BrwIni.ReadInteger(Name+'Key','KeyNo',1);
  BrwIni.ReadSection(Name,BrwListe);
  if BrwListe.Count > 0 then begin
    For i:= 0 to BrwListe.Count-1 do begin
      LStr:= BrwIni.ReadString(Name,BrwListe[i],'');
      if Pos(',',LStr) > 0 then begin
        Val(Copy(LStr,1,Pos(',',LStr)-1),Len,Code);
        Delete(LStr,1,Pos(',',LStr));
        Val(LStr,Idx,Code);
      end
      else begin
        Idx:= i+1;
        Val(LStr,Len,Code);
      end;
      SListe.AddObject(BrwListe[i],TUeberschriftObject.Init(BrwListe[i],Idx,Len));
    end;
    Spalten:= SListe;
  end
  else begin
    if Table <> NIL then begin
      if Table.IsamRecord.Count > 0 then begin
        FNr:= 0;
        For i:= 0 to Table.IsamRecord.Count-1 do begin
          SStr:= Table.IsamRecord[i];
          if (Pos('DUMMY',Uppercase(SStr)) = 0) and (Pos('IGNORE',Uppercase(SStr)) = 0) then begin
            Len:= 0;
            if Pos(':',SStr) > 0 then begin
              GetArray(SStr,Arr1,Arr2);
              For Feld:= Arr1 to Arr2 do begin
                FeldName:= Copy(SStr,1,Pos(':',SStr)-1);
                Strip(FeldName);
                if Arr1 <> Arr2 then FeldName:= FeldName + DezStr(Feld);
                LenStr:= Uppercase(SStr);
                Delete(LenStr,1,Pos(':',LenStr));
                Strip(LenStr);
                if Pos('ARRAY[',LenStr) > 0 then begin
                  Delete(LenStr,1,Pos('ARRAY[',LenStr));
                  Delete(LenStr,1,Pos(']',LenStr));
                end;
                if Pos('STRING',LenStr) > 0 then begin
                  if Pos('[',LenStr) > 0 then begin
                    Delete(LenStr,1,Pos('[',LenStr));
                    LenStr:= Copy(LenStr,1,Pos(']',LenStr)-1);
                    Val(LenStr,Len,Code);
                  end
                  else Len:= 255;
                end
                else if Pos('INTEGER',LenStr) > 0 then Len:= 8
                else if Pos('WORD',LenStr) > 0 then Len:= 8
                else if Pos('BYTE',LenStr) > 0 then Len:= 4
                else if Pos('LONGINT',LenStr) > 0 then Len:= 10
                else if Pos('REAL',LenStr) > 0 then Len:= 10
                else if Pos('BOOLEAN',LenStr) > 0 then Len:= 4;
                {if Len > 0 then begin}
                Inc(FNr);
                SListe.AddObject(FeldName,TUeberschriftObject.Init(FeldName,FNr,Len));
                {end;}
              end;
            end;
          end;
        end;
        Spalten:= SListe;
      end;
    end;
  end;
  SListe.Free;
  BrwListe.Free;
  BrwIni.Free;
  Result:= K;
end;

(*Function TIsamBrowser.GetRow(GetProc: Feld_GetProc; var DATA):String;
var S: String;
    i,X,Code: Integer;
    U:TUeberschriftObject;
begin
  S:= '';
  For i:= 0 to Spalten.Count-1 do begin
    if Spalten.Objects[i] <> NIL then begin
      U:= TUeberschriftObject(Spalten.Objects[i]);
      X:= U.Idx;
      if (X > 0) and (U.Breite > 0) then S:= S + GetProc(X,Table,DATA);
    end;
  end;
  Result:= ' '+S+#13
end;*)
Function TIsamBrowser.GetRow(GetProc: Feld_GetProc; var DATA):String;
var S: String;
    ss : String; {NS}
    i,X,Code : Integer;
    L,ii: Integer; {NS}
    U:TUeberschriftObject;
    SChar: Char;
begin
  S:= '';
  SChar:= SeparatorChar;
  For i:= 0 to Spalten.Count-1 do begin
    SChar:= SeparatorChar;
    if Spalten.Objects[i] <> NIL then begin
      U:= TUeberschriftObject(Spalten.Objects[i]);
      X:= U.Idx;
      L := U.Breite; {NS}
      ss := GetProc(X,Table,DATA); {NS}
      ii := Pos(SChar,ss); {NS}
      if ii > 0 then delete(ss,ii,1); {NS}
      if Pos(JustRightChar,SS) > 0 then begin
        Delete(SS,Pos(JustRightChar,SS),1);
        SS:= F(SS,L)+JustRightChar + SChar;
      end
      else if Pos(JustLeftChar,SS) > 0 then begin
        Delete(SS,Pos(JustLeftChar,SS),1);
        SS:= F(SS,L)+JustLeftChar + SChar;
      end
      else if Pos(JustCenterChar,SS) > 0 then begin
        Delete(SS,Pos(JustCenterChar,SS),1);
        SS:= F(SS,L)+JustCenterChar + SChar;
      end
      else begin
        ss := F(SS,L)+SChar;
                       {NS}  {Ich bin davon ausgegangen, da▀ das Feld die LΣnge L hat zuzⁿglich das Zeichen
                               ^. Das Zeichen ^ habe ich entfernt, den String auf die LΣnge L aufgefⁿllt und das Zeichen
                               ^ wieder angefⁿgt. Beachte bitte, das das Zeichen ^ variabel ist und im Browser eingestellt
                               werden kann. }
      end;
      if (X > 0) and (U.Breite > 0) then S:= S + ss; {NS}
    end;
  end;
  Result:= ' '+S+#13
end;

Procedure TIsamBrowser.SetupBrowser(aParent: TForm);
begin
  BrowserSetup(aParent,GetAppName,Name,Table);
  ReadIni;
  SetAndUpDateBrowserScreen('',0);
end;

Procedure TIsamBrowser.SetTable(Const Value: TIsamTable);
var FNr,i,Len,Code,Feld,Arr1,Arr2: Integer;
    SStr,FeldName,LenStr: String;
    SListe: TStringList;
begin
  FTable:= Value;
  if (csDesigning in ComponentState) then begin
    if Assigned(Value) then begin
      if FSpalten.Count = 0 then begin
        if Value.IsamRecord.Count > 0 then begin
          SListe:= TStringList.Create;
          FNr:= 0;
          For i:= 0 to Value.IsamRecord.Count-1 do begin
            SStr:= Value.IsamRecord[i];
            if (Pos('DUMMY',Uppercase(SStr)) = 0) and (Pos('IGNORE',Uppercase(SStr)) = 0) then begin
              Len:= 0;
              if Pos(':',SStr) > 0 then begin
                GetArray(SStr,Arr1,Arr2);
                For Feld:= Arr1 to Arr2 do begin
                  FeldName:= Copy(SStr,1,Pos(':',SStr)-1);
                  Strip(FeldName);
                  if Arr1 <> Arr2 then FeldName:= FeldName + DezStr(Feld);
                  LenStr:= Uppercase(SStr);
                  Delete(LenStr,1,Pos(':',LenStr));
                  Strip(LenStr);
                  if Pos('ARRAY[',LenStr) > 0 then begin
                    Delete(LenStr,1,Pos('ARRAY[',LenStr));
                    Delete(LenStr,1,Pos(']',LenStr));
                  end;
                  if Pos('STRING',LenStr) > 0 then begin
                    if Pos('[',LenStr) > 0 then begin
                      Delete(LenStr,1,Pos('[',LenStr));
                      LenStr:= Copy(LenStr,1,Pos(']',LenStr)-1);
                      Val(LenStr,Len,Code);
                    end
                    else Len:= 255;
                  end
                  else if Pos('INTEGER',LenStr) > 0 then Len:= 8
                  else if Pos('WORD',LenStr) > 0 then Len:= 8
                  else if Pos('BYTE',LenStr) > 0 then Len:= 4
                  else if Pos('LONGINT',LenStr) > 0 then Len:= 10
                  else if Pos('REAL',LenStr) > 0 then Len:= 10
                  else if Pos('BOOLEAN',LenStr) > 0 then Len:= 4;
                  {if Len > 0 then begin}
                    Inc(FNr);
                    SListe.AddObject(FeldName,TUeberschriftObject.Init(FeldName,FNr,Len));
                  {end;}
                end;
              end;
            end;
          end;
          Spalten:= SListe;
          SListe.Free;
        end;
      end;
    end;
  end;
end;

procedure TIsamBrowser.SetSpalten(const Value: TStringList);
var N,i,xLen,Code: Integer;
    SStr,TStr: String;
begin
  FSpalten.Assign(Value);
  if BrowserHeader <> NIL then BrowserHeader.Sections.Clear;
  if Value <> NIL then begin
    if FSpalten.Count > 0 then begin
      n:= 0;
      for i:= 0 to FSpalten.Count-1 do begin
        if FSpalten.Objects[i] <> NIL then begin
          with TUeberschriftObject(FSpalten.Objects[i]) do begin
            SStr:= Txt;
            xLen:= Breite;
            if xLen > 0 then begin
              if BrowserHeader <> NIL then begin
                BrowserHeader.Sections.Insert(N,SStr);
                BrowserHeader.SectionWidth[N]:= (xLen * 7)+8;
                inc(N);
              end;
            end;
          end;
        end;
      end;
    end;
  end;
end;

Procedure TIsamBrowser.ResizeHeader;
var idx,I,K,Len,x: Integer;
    AktDir,SStr: String;
    SListe: TStringList;
    BrwIni: TIniFile;
    U: TUeberschriftObject;
begin
  AktDir:= ExtractFilePath(Application.ExeName);
  if BrowserHeader <> NIL then begin
    if BrowserHeader.Sections.Count > 0 then begin
      SListe:= TStringList.Create;
      BrwIni:= TIniFile.Create(AktDir + GetAppname+'.INI');
      if Table <> NIL then K:= Table.KeyNo else K:= 1;
      BrwIni.WriteInteger(Name+'Key','KeyNo',K);
      if Spalten.Count > 0 then begin
        for i:= 0 to Spalten.Count-1 do begin
          if Spalten.Objects[i] <> NIL then begin
            U:= TUeberschriftObject(Spalten.Objects[i]);
            x:= BrowserHeader.Sections.Indexof(Spalten[i]);
            if x > -1 then begin
              Len:= Round((BrowserHeader.SectionWidth[x]-8)/7);
              if Len < 0 then Len:= 0;
              SStr:= BrowserHeader.Sections[x];
              Idx:= U.Idx;
              SListe.AddObject(SStr, TUeberschriftObject.Init(SStr,idx,Len));
              SStr:= DezStr(Len)+','+DezStr(idx);
              if Len > 0 then BrwIni.WriteString(Name,BrowserHeader.Sections[x],SStr);
            end
            else begin
              SStr:= U.Txt;
              Len:= U.Breite;
              Idx:= U.idx;
              SListe.AddObject(SStr,TueberschriftObject.Init(SStr,idx,Len));
            end;
          end
          else Errorwindow('Object is NIL',Spalten[i]);
        end;
      end
      else Errorwindow('Spalte is NIL','');
      Spalten:= SListe;
      SListe.Free;
      BrwIni.Free;
    end;
  end;
  ReadIni;
  SetAndUpdateBrowserScreen('', 0);
end;

procedure TIsamBrowser.ShowErrorOccured(EClass: Integer);
begin
  if EClass > 1 then Inherited showErrorOccured(EClass);
end;

procedure TIsamBrowser.ClearIncSS;
begin
  { Make sure to call this before going to a new key number }
  IncSS := '';
  LowKey := BaseLKey;
  HighKey := BaseHKey;
end;

function TIsamBrowser.WriteStringOut(var S : BRLRowEltString;
                                         LineNr : word;
                                         XOfs : integer) : word;
var
    SegmentString  : string;
    Just,i,j    : integer;
    Rect   : TRect;
    x   : integer;
    SegNum : integer;
    SaveFontColor,
    SaveColor : TColor;

    function StUpCase(St : string) : string;
    var i : integer;
    begin
      Result := st;
      for i := 1 to length(st) do result[i] := upcase(result[i]);
    end;

begin
  Result := GetTextOutPosY(LineNr);

  Rect.Left := 0{1};
  Rect.Top := Result;
  Rect.Bottom := Result + TotalCharHeight;

  if Assigned(FHeader) then
    Rect.Right := BrowserHeader.Width
  else
    Rect.Right := Width;

  Canvas.FillRect(Rect);

  SegmentString := '';
  SegNum := 0;

  if Assigned(FHeader) then begin
     BrowserHeader.Left := xOfs + Left;
     BrowserHeader.Width := Width - xOfs;
  end;

  Just := DT_Left;
  for i := 1 to length(S) do begin
    if (S[i] = JustLeftChar) then Just := DT_left else
    if (S[i] = JustCenterChar) then Just := DT_Center else
    if (S[i] = JustRightChar) then Just := DT_Right else
    if (S[i] = SeparatorChar) or (i = length(S)) then begin
      if i = length(S) then SegmentString := SegmentString + S[i];
      { SegmentString now contains the segment }
      Rect.Top := Result;
      Rect.Bottom := Result + TotalCharHeight;
      x := 1;
      if Assigned(FHeader) then begin
         for j := 0 to SegNum-1 do
          x := x + BrowserHeader.SectionWidth[j];
         Rect.Left := XOfs + FTextMargin.Left + x + 2;
         if SegNum = BrowserHeader.Sections.Count-1 then
           Rect.Right := Rect.Left + BrowserHeader.SectionWidth[SegNum]-20
         else
           Rect.Right := Rect.Left + BrowserHeader.SectionWidth[SegNum]-4;
      end else begin
         Rect.Left := XOfs + FTextMargin.Left + 2;
         Rect.Right := XOfs + FtextMargin.Left + Width - 2;
      end;

      { Draw the text }
      DrawText(Canvas.Handle,@SegmentString[1],length(SegmentString),Rect,Just+DT_NoPrefix);

      { Process the incremental search string }
      if (IncSS <> '') and (SegNum = KeySection) and (Just = DT_Left) and
         (copy(StUpCase(SegmentString),1,Length(IncSS)) = IncSS) then begin
           { Do incremental search string highlight }
           SaveColor := Canvas.Brush.Color;
           SaveFontColor := Canvas.Font.Color;
           Canvas.Font.Color := IncSSTxtColor;
           Canvas.Brush.Color := IncSSColor;
           DrawText(Canvas.Handle,@SegmentString[1],length(IncSS),Rect,DT_Left+Dt_NoPrefix);
           Canvas.Font.Color := SaveFontColor;
           Canvas.Brush.Color := SaveColor;
      end;
      { Draw vertical lines }
      Canvas.Pen.Color := clGray;
      Rect.Right := Rect.Right + 2;
      Canvas.MoveTo(Rect.Right-2,Rect.Top);
      Canvas.LineTo(Rect.Right-2,Rect.Bottom);
      Canvas.Pen.Color := clWhite;
      Canvas.MoveTo(Rect.Right-1,Rect.Top);
      Canvas.LineTo(Rect.Right-1,Rect.Bottom);
      inc(SegNum);
      SegmentString := '';
    end else begin
      SegmentString := SegmentString + S[i];
    end;
  end;
end;

procedure TIsamBrowser.KeyDown(var Key: Word; Shift: TShiftState);
var Data,Dup: Pointer;
begin
  inherited KeyDown(Key, Shift);
  if CanCallLowBrowser then begin
    case Key of
      vk_Delete: if Table <> NIL then begin
                   Table.Ref:= GetCurrentDatRef;
                   GetMem(Data,Table.RecSize);
                   GetMem(Dup,Table.RecSize);
                   Table.Get(Data^,Dup^);
                   Table.Delete(Data^,Dup^);
                   FreeMem(Dup,Table.RecSize);
                   FreeMem(Data,Table.RecSize);
                   SetAndUpdateBrowserScreen(Table.Key,Table.Ref);
                 end;
      vk_Insert: OnDblClick(Self);
    end;
  end;
end;

procedure TIsamBrowser.KeyPress(var Key : char);
Const AllowedKeys = [' '..'z'];
var SaveIncSS, SaveLowKey, SaveHighKey : IsamKeyStr;
begin
  if not AllowIncss then Exit;
  SaveIncSS := IncSS;
  if Key = #8 then begin { Backspace }
    if IncSS <> '' then Delete(IncSS,Length(IncSS),1);
  end else begin
    if Key in AllowedKeys then IncSS := IncSS + UpCase(Key)
    else begin
      Messagebeep(0);
      Exit;
    end;
  end;
  if not CanCallLowBrowser then Exit;
  { Changing either the low or the high key can cause use to not have any
    records left to show, so if either fails, we need to undo the changes. }
  try
    SaveLowKey := LowKey;
    LowKey := BaseLKey + IncSS;
    try
       SaveHighKey := HighKey;
       HighKey := BaseHKey + IncSS;
    except
       HighKey := SaveHighKey;
       LowKey := SaveLowKey;
       IncSS := SaveIncSS;
       MessageBeep(0);
    end;
  except
    LowKey := SaveLowKey;
    IncSS := SaveIncSS;
    MessageBeep(0);
  end;
end;

end.